home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / MacPerl ƒ / lib / GUSI.ph < prev    next >
Text File  |  1993-10-23  |  3KB  |  138 lines
  1. # Perl interface to GUSI, M. Neeracher 28Nov92
  2.  
  3. package GUSI;
  4.  
  5. # Address families
  6.  
  7. sub AF_UNSPEC        { 0;    }
  8. sub AF_UNIX            { 1;    }
  9. sub AF_INET            { 2;    }
  10. sub AF_CTB             { 3;    }
  11. sub AF_FILE         { 4;    }
  12. sub AF_PPC             { 5;    }
  13. sub AF_APPLETALK    { 16;    }
  14. sub ATALK_SYMADDR    { 272;}
  15.  
  16. # Socket types
  17.  
  18. sub SOCK_STREAM     { 1;    }
  19. sub SOCK_DGRAM     { 2;    }
  20.  
  21. # Address formats
  22.  
  23. sub pack_sockaddr_in    {
  24.     local($family, $addr, $port) = @_;
  25.  
  26.     if ($addr =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)/) {
  27.         $addr = pack('C4', $1, $2, $3, $4);
  28.     } else {
  29.         local(@x) = gethostbyname($addr);
  30.         return undef unless @x;
  31.         $addr = $x[4];
  32.     }
  33.     
  34.     pack("s S a4 x8", $family, $port, $addr);
  35. }
  36.  
  37. sub unpack_sockaddr_in {
  38.     local($addr) = @_;
  39.     local($family, $port, $a1, $a2, $a3, $a4) = unpack("s S C4 x8", $addr);
  40.     
  41.     ($family, "$a1.$a2.$a3.$a4", $port);
  42. }
  43.  
  44. sub pack_sockaddr_un    {
  45.     local($family, $path) = @_;
  46.     
  47.     pack("s a108", $family, $path);
  48. }
  49.  
  50. sub unpack_sockaddr_un {
  51.     local($addr) = @_;
  52.     
  53.     return unpack("s a108", $addr);
  54. }
  55.  
  56. sub pack_sockaddr_atlk    {
  57.     local($family, $net, $node, $socket) = @_;
  58.     
  59.     pack("s s C C", $family, $net, $node, $socket);
  60. }
  61.  
  62. sub unpack_sockaddr_atlk {
  63.     local($addr) = @_;
  64.     
  65.     unpack("s s C C", $addr);
  66. }
  67.  
  68. sub pack_sockaddr_atlk_sym    {
  69.     local($family, $obj, $type, $zone) = @_;
  70.     local($fmt);
  71.     
  72.     $fmt    =    "s C a" . ((length($obj) & ~1) + 1);
  73.     $fmt    .=    "C a" . ((length($type) & ~1) + 1);
  74.     $fmt    .=    "C a" . ((length($zone) & ~1) + 1);
  75.     
  76.     pack($fmt, $family, length($obj), $obj, length($type), $type, length($zone), $zone);
  77. }
  78.  
  79. sub unpack_sockaddr_atlk_sym {
  80.     local($addr) = @_;
  81.     local($len, $obj, $type, $zone);
  82.     
  83.     ($len, $addr) = unpack("x2 C a*", $addr);
  84.     ($obj, $addr) = unpack("a$len " . ($len & 1 ? "" : "x ") . "a*", $addr);
  85.     ($len, $addr) = unpack("x2 C a*", $addr);
  86.     ($type, $addr) = unpack("a$len " . ($len & 1 ? "" : "x ") . "a*", $addr);
  87.     ($len, $addr) = unpack("x2 C a*", $addr);
  88.     ($zone, $addr) = unpack("a$len " . ($len & 1 ? "" : "x ") . "a*", $addr);
  89.     
  90.     ($family, $obj, $type, $zone);
  91. }
  92.  
  93. sub pack_sockaddr_ppc    {
  94.     local($family, $type, $name, $porttype) = @_;
  95.     local($ppcNBPTypeLocation, $smRoman, $ppcByString)    = (2,0,2);
  96.     
  97.     pack("s s C a101 s C a32 x s C a32", 
  98.         $family, 
  99.         $ppcNBPTypeLocation, length($type), $type,
  100.         $smRoman, length($name), $name, $ppcByString, length($porttype), $porttype);
  101. }
  102.  
  103. sub pack_sa_constr_file    {
  104.     local($count, $constr, $cur) = (0, "");
  105.     
  106.     while ($cur = shift) {
  107.         ++$count;
  108.         $constr .= pack("A4", $cur);
  109.     }
  110.     
  111.     pack("s", $count) . $constr;
  112. }
  113.  
  114. sub pack_sa_constr_atlk    {
  115.     local($count, $constr, $cur) = (0, "");
  116.     
  117.     while ($cur = shift) {
  118.         ++$count;
  119.         $constr .= pack("x4 C a33", length($cur), $cur);
  120.     }
  121.     
  122.     pack("s", $count) . $constr;
  123. }
  124.  
  125. sub pack_sa_constr_ppc    {
  126.     local($type) = @_;
  127.     
  128.     pack("C a33", length($type), $type);
  129. }
  130.  
  131. # Flags for choose()
  132.  
  133. sub CHOOSE_DEFAULT    {    1;    }
  134. sub CHOOSE_NEW         {    2;    }
  135. sub CHOOSE_DIR         {    4;    }
  136.  
  137. 1;
  138.